home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / graphic / postogrf.zip / COPYBLOC.INC < prev    next >
Text File  |  1990-06-04  |  34KB  |  918 lines
  1. { program CopyBlock.inc
  2.   written by Thomas B. Passin in Turbo Pascal 4.0.
  3.    For use in POSTogrf/LIPSogrf.  Shows, resizes, and moves an open
  4.    rectangle.  This represents the allowed size of the graph when printed
  5.    (e.g., 8 X 6.25 in for a MITRE report).  When the box is located in
  6.    the upper left corner of the screen, the box represents the copybox
  7.    as located at the printer margin.  If the box is moved away from the
  8.    corner, it shows whether the graph can be cropped to fit inside the box.
  9.  
  10.   22 May 90 Other sections of code have also been moved here:
  11.          procedures Repaint1, MoveLabel, Attributes.
  12.  
  13.  27 Apr 89 Now XOR's the box when moving.
  14.  18 Oct 88 v1.0x4.  Added var noshow to toggle rectangle on or off:
  15.          modified CopyBlock, CopyBlockMenu.
  16.  20 Sept 88. v1.0x3.  Surounded each readln by textcolor(white),
  17.          textcolor(black) pairs.  Needed to overcome BGI bug.
  18.          Changed type colors to word to avoid collision with
  19.          CRT unit.
  20.  14 Sept 88.  v1.0x2.  Added HOME key to MoveCopyBlock: takes box to upper
  21.          left corner. Added HOME to set of Movers in CopyBlockMenu.
  22.  13 Sept 88.  v1.0x1.  Works.
  23.  }
  24.  
  25. (*{$DEFINE test}*)
  26. {$IFDEF test}
  27. uses graph, CRT;
  28. type videocolors = (color, mono);
  29.      {mcolors = (yellow, white, black);}
  30.      colors = word;
  31.      string80 = string[80];
  32. const  ESC = #27;  BS  = #8; CR = #13;  LF = #10;
  33.        Uparrow  = #72;     Downarrow  = #80;
  34.        Leftarrow  = #75;   Rightarrow  = #77;
  35.        Del  = #83;         Ins  = #82;
  36.        Home  = #71;        En  = #79;
  37.        PF1 = #59;   PF2 = #60;   PF3 = #61;   PF4 = #62;   PF5 = #63;
  38.        PF6 = #64;   PF7 = #65;   PF8 = #66;   PF9 = #67;   PF10 = #68;
  39. var VidCol :videocolors;
  40.     key :char;
  41. procedure ScrConv(x,y:integer); begin end;  { dummy procedures for debugging }
  42. procedure SetColor(cc:colors); begin end;
  43. procedure repaint; begin end;
  44. {$ENDIF}
  45.  
  46. { ---------------------------------------------------------------------
  47.                      Part of the RePaint procedure
  48.   --------------------------------------------------------------------- }
  49. Procedure RePaint1;
  50. var savePrtSize: integer;
  51.     t1: integer;
  52. begin
  53.      here := JimFileStart;
  54.      SavePrtSize := TempText.PrtSize;
  55.      SetColor(white);
  56.      t1:= 10; SetPrtFontSize(t1);
  57.      SetTextStyle(SansSerifFont,Horizdir,UserCHarSize);
  58.      done := false;
  59.      if count > 0 then Repeat DrawJimFile until done ;
  60.      if VidCol = color then SetColor(yellow) else SetColor(white);
  61.      Line(0,GetMaxY - 3*LinesPerChar,GetMaxX,GetMaxY-3*LinesPerChar);
  62.      if head = nil then exit;
  63.      cp := head;
  64.      repeat
  65.            showLabel(cp, white);
  66.            cp := cp^.link;
  67.      until cp = nil;
  68.      if select <> nil then HighLight(select);
  69.      if LConfig.DoBar then DoVGBar;
  70.      RestorePrtFontSize(SavePrtSize);
  71.      TempText := select^;
  72.      SetUpLabel(select);
  73. end;
  74.  
  75. { ------------------------------------------------------------------------
  76.                  Size the copyblock to fit the graph
  77.   ------------------------------------------------------------------------ }
  78. procedure AutoSizeCopyBlock;
  79. var maxMinRect: rect;        {accumulate max, min corners}
  80.     x1, x2, y1, y2: integer;
  81.     cpx, cpy      : integer; {current point in Postscript coords}
  82.  
  83.     procedure DoRectMaxMin(x,y: integer; var r: rect);
  84.     begin
  85.        with r do begin
  86.            if x < LLx then LLx := x else
  87.               if x > URx then URx := x;
  88.            if y < LLy then LLy := y else
  89.               if y > URy then URy := y;
  90.         end;
  91.     end;
  92.  
  93.     procedure SizeJimFile;
  94.     var XPos, Ypos, error, temp  : integer;
  95.         PenDia                   : word;
  96.         n1                       : word;
  97.         str                      : string80;
  98.         sFlag                    : boolean;
  99.     begin
  100.         GetAWord(str);
  101.         case GraphFile of
  102.             GRAPHL, LIPSGRF: begin
  103.                (*if str = 'EXIT' then begin done := true; exit ; end ELSE
  104.                if str = 'MAP' then   { move to position }
  105.                   begin GetAWord(str); Val(str,Xpos,error);
  106.                   GetAWord(str); Val(str,Ypos,error);
  107.                   ScrConv(XPos, YPos);
  108.                   MoveTo(Xpos,YPos);
  109.                 end ELSE
  110.                   if str = 'DAP' then   { draw to position }
  111.                   begin GetAWord(str); Val(str,Xpos,error);
  112.                   GetAWord(str); Val(str,Ypos,error);
  113.                   ScrConv(XPos,YPos);
  114.                   LineTo(Xpos,YPos);
  115.                end ELSE
  116.                   if str = 'SPD' then  {set pen diameter - only an approximation }
  117.                   begin GetAWord(str); Val(str,PenDia, error);
  118.                   PenDia := word(round(10 * PenDia/VPrtScale)) div 3;
  119.                   SetLineStyle(0,0,PenDia);
  120.                end ELSE
  121.                   if str = 'FONT' then {he asks for internal landscape font - fake it }
  122.                     begin GetAWord(str);
  123.                        if str = '3' then  begin
  124.                           temp:= 12; SetPrtFontSize(temp);
  125.                         end; {else;}
  126.                end ELSE
  127.                   if str = 'TEXT' then begin {write the following text string }
  128.                      GetAQuote(str); OutText(str);
  129.                   end ELSE {nothing} *)
  130.              end; {case GRAPHL, LIPSGRF}
  131.             POSTSCRIPT: begin
  132.            temp := 13; SetPrtFontSize(temp);
  133.            if str[1] = 's' then sFlag := true else sFlag := false;
  134.                if str[1] = '%' then
  135.            repeat
  136.                   inc(here)
  137.                 until (JimFile^[here] = CR) or (JimFile^[here] = LF);
  138.                if str[1] = '(' then begin       {found a label}
  139.                   ParsePSstring(str,mark);
  140.                   x1 := textwidth(str);
  141.                   y1 := textheight(str);
  142.                   x1 := round(x1/Hscale);
  143.                   y1 := round(y1/VScale);
  144.                   doRectMaxMin(cpx - 50, cpy, maxMinRect);
  145.                   doRectmaxMin(cpx + x1 ,cpy +50 + y1 + y1 div 2, maxMinRect);
  146.                   here := mark;
  147.                 end ELSE
  148.                 if (str[1] = 'm') then begin
  149.                   if ((str = 'm') or (str = 'moveto')) then begin
  150.                     n1 := here - 1;
  151.                     GetAWordBack(str,n1); GetAWordBack(str, n1);
  152.                     Val(str, YPos, error);
  153.                     if error <> 0 then exit;
  154.                     GetAWordBack(str,n1);
  155.                     Val(str,XPos,error);
  156.                     if error <> 0 then exit;
  157.                     cpx := Xpos; cpy := Ypos;
  158.                     doRectMaxMin(cpx, cpy, maxMinRect);
  159.                    end;
  160.                 end ELSE
  161.                 if (str[1] = 'l') then begin
  162.                    if ((str = 'l') or (str = 'lineto')) then begin
  163.                       n1 := here - 1;
  164.                       GetAWordBack(str,n1); GetAWordBack(str, n1);
  165.                       Val(str, YPos, error);
  166.                       GetAWordBack(str,n1);
  167.                       Val(str,XPos,error);
  168.                       cpx := Xpos; cpy := Ypos;
  169.                       doRectMaxMin(cpx, cpy, maxMinRect);
  170.                     end;
  171.                 end ELSE if
  172.                    (sflag) and (str = 'setlinewidth') then begin
  173.                    {n1 := here -1; GetAWordBack(str,n1); GetAWordBack(str, n1);
  174.                    Val(str,PenDia,error);
  175.                    if error = 0 then
  176.                       PenDia := word(round(PenDia)) div 10;
  177.                       else PenDia := 1;
  178.                    SetLineStyle(0,0,PenDia);}
  179.                 end ELSE if (sFlag) and (str = 'sf') then begin
  180.                       {set active font size}
  181.                       {any labels here are default 13 pt labels}
  182.                    temp := 13; SetPrtFontSize(temp);
  183.                 end ELSE if (sFlag) and (str = 'setfont') then begin
  184.                    {temp := 13; SetPrtFontSize(temp);}
  185.                 end ELSE if (sFlag) and (str = 'showpage') then begin
  186.                    done := true; exit ;
  187.             end; {if..ELSE}
  188.          end; {POSTSCRIPT}
  189.